home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / Yerk 3.6.8 / System source / Color < prev    next >
Encoding:
Text File  |  1994-08-02  |  7.5 KB  |  256 lines  |  [TEXT/YERK]
  1. \ New ColorGraphPort support
  2. \ 6.18.87    rfl
  3. \ 9.21.88    rfl don't lock during calcrange
  4. \ 1.11.89    rfl    redone for multiple instances
  5. \ 1.28.89    rfl    helped getpalette in cwind
  6. \ 2.23.89    rfl    uget in rgbColor
  7. \ 6.1.89    rfl    adjustGray: pixmap now saturates to 0 or $ ffff
  8. \ 9.5.89    rfl    modified for generality and 16 bit images
  9. \ 3.6.92    rfl    changed 0 to 'lo $ 101 *' in adjustlimits: pixmap
  10. \                  which helps things if lo=hi
  11. \ 6.16.92    rfl    moved forecolor, backcolor out of class; changed lo $ 101 * back
  12. \                   to 0.
  13. \ 5.10.94    rfl    changed default cwindow to pmcourteous
  14.  
  15. \ : makeEven dup 1 and IF 1+ THEN ;
  16.  
  17. \ given a number, calculate the power of 2 to give that number
  18. : p2 ( n -- powerOf2) 100 0 DO 2/ dup 0= IF drop i leave THEN LOOP ;
  19.  
  20. \ ( b -- bool )  make a Forth boolean into a Toolbox boolean
  21. : Bool   8 << makeInt  ;
  22.  
  23. : foreColor ( ind --) makeint call PmForeColor ;
  24. : backColor ( ind --) makeint call PmBackColor ;
  25.  
  26. \ standard data structure for colors
  27. :CLASS rgbColor <super object
  28.  
  29.     int    red
  30.     int    green
  31.     int    blue
  32.  
  33.   :M put: put: blue put: green put: red ;M
  34.   :M get: uget: red uget: green uget: blue ;M
  35.  
  36. ;CLASS
  37.  
  38. \ general purpose global color records
  39. rgbColor  inColor
  40. rgbColor outColor
  41.  
  42.  
  43. 0 constant pmCourteous
  44. 1 constant pmDithered
  45. 2 constant pmTolerant
  46. 4 constant pmAnimated
  47. 8 constant pmExplicit
  48.  
  49. \ order of use: new, putwindow, fillgray, openwindow, set, activate?
  50. :CLASS palette <super handle
  51.  
  52.     int    size
  53.     var myWindow
  54.     int myUsage
  55.     int    tolerance
  56.  
  57. ( wind --)
  58.   :M putWindow: +base put: mywindow ;M
  59. ( usage --)
  60.   :M usage: put: myUsage ;M
  61.   :M tolerance: put: tolerance ;M
  62.   :M putSize: put: size ;M
  63.  
  64. ( #colors --)
  65.   :M new: put: size 0 int: size 0 int: myUsage w 0 call NewPalette put: self ;M
  66.   :M dispose: get: self call DisposePalette 0 m! ;M
  67.  
  68.   :M activate: get: myWindow call ActivatePalette ;M
  69. \ might change true to false for no updates on color environ change
  70.   :M set: get: myWindow get: self true bool call SetPalette ;M
  71.  
  72.   :M getColor: { ind -- }
  73.     get: self ind makeint abs: outColor call GetEntryColor ;M
  74.   :M setColor: { ind -- }
  75.     get: self ind makeint abs: inColor call SetEntryColor ;M
  76.  
  77. \ fills the color table evenly rgb - as IMAC says, do we want black,white
  78. \    to be the first two colors? i don't think so here, but we do it anyway
  79.   :M fillGray:  get: size 2
  80.     DO $ 10000 i 1- get: size */ i+ 1- dup dup put: inColor i setColor: self LOOP
  81.     $ ffff dup dup put: incolor 1 setcolor: self
  82.     0 dup dup put: incolor 0 setcolor: self
  83.     activate: self ;M
  84.  
  85.   :M putCTable: { ctable - } get: ctable m@ int: myUsage w 0 
  86.     call CTab2Palette ;M
  87.  
  88. ;CLASS
  89.  
  90. \ instantiate a global palette for operations
  91. palette thePalette
  92.  
  93. \ general purpose colortable <-> palette operations
  94. ( srcTableHndl  dstPaletteHndl use tol -- )
  95. : cTab2Palette pack call CTab2Palette ;
  96. ( srcPaletteHndl dstCTabHndl -- )
  97. : Palette2CTab call Palette2CTab ;
  98.  
  99. :CLASS ColorTable <super handle
  100.  
  101. \ fill with an existing colorTable
  102.   :M fill: { myCTable -- } lock: self lock: myCTable
  103.      ptr: myCTable 8+ ptr: self 8+ size: self 8 -
  104.             cmove unlock: myCTable unlock: self ;M
  105.  
  106.   :M seed: 0 call getCTSeed m@ >ptr ! ;M
  107.  
  108. ( #colors --)
  109.   :M new: dup 8* 8+ new: super 1- ptr: self 6 + w! seed: self ;M
  110.   :M dispose: m@ call disposCTable 0 m! ;M
  111.  
  112.   :M getPalette: { pal -- }    get: pal m@  Palette2CTab ;M
  113.   :M toPalette:  { pal -- } m@ get: pal 0 0 CTab2Palette ;M
  114.  
  115. ( -- size )
  116.   :M ctsize: ptr: self 6 + w@ 1+ ;M
  117.  
  118. ( #colors -- )    \ useful to change an existing colorTable's size
  119.   :M init: dup 8* 8+ setSize: self
  120.     1- ptr: self 6 + w! seed: self ;M
  121.  
  122.   :M fillGray: { \ nextAddr vals -- } lock: self
  123.     ptr: self 8+ -> nextAddr ctSize: self 0
  124.     DO i nextAddr w! 2 ++> nextAddr $ 10000 i ctsize: self */ i+ -> vals 3 0
  125.         DO vals nextAddr w! 2 ++> nextAddr LOOP
  126.     LOOP unlock: self ;M
  127.  
  128. ;CLASS
  129.  
  130. \ instantiate a global colortable for operations
  131. colorTable theCTable
  132.  
  133.  
  134. \ : CALCMB { X1 X0 -- B M } 256. X1 X0 - >FLOAT F/
  135. \     FDUP X0 >FLOAT F* FNEGATE SWAP ;
  136. \ 
  137. \ ( max min -- M*100 B*100 )
  138. \ : GETMB  CALCMB 100. F* ROUND FLOAT> SWAP
  139. \     100. F* ROUND FLOAT> ;
  140.  
  141. ( max min -- M*100 B*100 )
  142. : GETMB { X1 X0 -- M*100 B*100 } 256 100 X1 X0 -  */
  143.     DUP X0  * NEGATE ;
  144.  
  145. :CLASS PixMap <super handle 
  146.  
  147.     colorTable myCTab
  148.     rect    destRect
  149.     int        mask        \ $ffff for inverted images, 0 normal
  150.     var        pixImage    \ pointer to the image for this pixMap
  151.  
  152. \ **************************
  153. \ INITIALIZE METHODS
  154. \ **************************
  155.  
  156. \ image black-on-white or white-on-black
  157.   :M negate: $ FFFF put: mask ;M
  158.   :M normal: clear: mask ;M
  159.   :M invert: $ FFFF get: mask xor put: mask ;M 
  160.  
  161. \ changes number bits/pixel
  162.   :M putBits/pixel: m@ >ptr 32 + w! ;M
  163.   :M getBits/pixel: m@ >ptr 32 + w@ ;M
  164.  
  165. \ boundRect is the rectangle bordering the image
  166.   :M putBounds: ( l t r b -- ) m@ >ptr 6 + put: rect ;M
  167.   :M getBounds: ( -- l t r b ) m@ >ptr 6 + get: rect ;M
  168.   :M putBoundsRect: ( rect --) m@ >ptr 6 + 8 cmove ;M
  169.  
  170. \ destRect is the destination rectangle that the contents of boundsrect will be stuffed
  171.   :M putDest:   put: destRect ;M
  172.   :M getDest:   get: destRect ;M
  173.  
  174. \ should I lock these first?
  175. ( addr --)
  176.   :M putImage: +base m@ >ptr ! ;M
  177. ( rowbytes --)    \ add $ 8000 for pixel image
  178.   :M putRowBytes: ( makeEven) $ 8000 + m@ >ptr 4+ w! ;M
  179.  
  180. \ **************************
  181. \ CREATION AND DISPOSAL METHODS
  182. \ **************************
  183.  
  184. ( image --) \ get a new pixMap structure from Toolkit
  185.   :M new: put: pixImage                    \ store the image for this pixMap
  186.         0 call NewPixMap m!                \ get handle to pixmap
  187.         ptr: self 42 + @ put: myCTab    \ get handle to colortable
  188.         #colors: [ obj: pixImage ] dup    \ get number of colors in image
  189.         init: myCTab                    \ initialize the colorTable
  190.         p2 putBits/pixel: self    
  191.         fillgray: myCTab ;M
  192.  
  193.   :M dispose: m@ call DisposPixMap 0 m! ;M
  194.  
  195. \ **************************
  196. \ MANIPULATION METHODS
  197. \ **************************
  198.  
  199. ( ctable --)
  200.   :M putCTable: m@ >ptr 42 + ! ;M
  201. \ puts handle into global colortable for manipulation as an object
  202.   :M getCTable: m@ >ptr 42 + @ put: theCTable ;M
  203.  
  204. ( addr rowBytes b/p l t r b --)
  205.   :M set: putBounds: self
  206.     putBits/pixel: self putRowBytes: self putImage: self ;M
  207.  
  208. \ creates new pixmap based on image to display
  209.   :M Prep: { pix -- } dispose: self                    \ get rid of old pixmap
  210.     pix    new: self                                    \ make new one
  211.     ptr: pix rowBytes: pix                            \ set up parameters
  212.     bits/pixel: pix 8 min getRect: pix 
  213.     set: self
  214.     getBounds: self putDest: self ;M
  215.  
  216. \ takes the pixMap and copies it into the window on the stack
  217. \   using parameters set by prep:
  218.   :M Copy: { wind -- } ptr: self +base wind 2+ @ >ptr +base
  219.     ptr: self 6 + +base abs: destRect w 0 wind 24 + @    \ use vsrgn of wind
  220.     call copyBits ;M
  221.  
  222. ( destPixMap --) \ copies this pixMap into destPixMap on stack
  223.   :M =: @ m@ swap call copyPixMap ;M
  224.  
  225. \ **************************
  226. \ COLORTABLE ADJUSTMENTS
  227. \ **************************
  228.  
  229. \ given the range of values in an image, this will attempt to
  230. \   linearly scale the contents of the image to the number of colors
  231. \   in the pixMaps color table.
  232.  
  233.   :M adjustLimits: { hi lo \ nextAddr vals M B -- }
  234.     getcTable: self lock: theCTable        \ put pixMap's ctab into global obj
  235.     ptr: theCTable 8+ -> nextAddr        \ set up pointer to entry
  236.     hi lo getMB -> B -> M                \ calc limits of values
  237.     1 getBits/pixel: self << 0            \ get #colors DO limit
  238.     DO     i nextAddr w! 2 ++> nextAddr    \ begin filling ctable
  239.          i lo <=
  240.         IF   0                            \ force to zero
  241.         ELSE i hi >=
  242.              IF  $ ffff
  243.              ELSE $ ffff $ 10000 M i * B + $ 6400 */ i+ min 0 max
  244.              THEN
  245.         THEN   get: mask xor -> vals 3 0
  246.         DO vals nextAddr w! 2 ++> nextAddr LOOP
  247.     LOOP unlock: theCTable ;M            \ done, so unlock ctable
  248.  
  249.   :M adjustGray: range: [ obj: pixImage ] drop adjustLimits: self ;M
  250.  
  251. \ just fill the ctable from 0-255 grayscale
  252.   :M fillgray: fillGray: myCtab ;M
  253.  
  254. ;CLASS
  255.  
  256.